Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue32/listview/LISTVIEW.ZIP/FileHolder.pas

Pascal/Delphi Source File | 1998-01-07 | 6.1 KB | 255 lines

unit FileHolder;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ShellAPI,
  FileCtrl, Dialogs;

type

  TFileSortType =(sbName,sbDate,sbSize,sbType,sbAttr);

  TFileStat = class
  private
    FIcon: integer;
    FHint: string;
    function  getIcon: integer;
    function  getHint: string;
  public
    Name: string;
    Size: string;
    Date: TDateTime;
    Attr: string[4];
    Fldr: Boolean;
    property Icon: integer read getIcon write FIcon;
    property Hint: string read getHint write FHint;
  end;

  TFileHolder = class(TList)
  private
    FFolder: string;
    FFoldersToo: Boolean;
    procedure setFolder(value: string);
    procedure setFoldersToo(value: Boolean);
    function  GetFileStat(Index: integer): TFileStat;
    procedure PutFileStat(Index: integer; FileList: TFileStat);
    procedure clearList;
  public
    destructor Destroy; override;
    procedure  readFiles;
    procedure  sortFiles(sortType: TFileSortType; ascending: Boolean);
    property   Files[Index: integer]: TFileStat read GetFileStat write PutFileStat;
    property   Folder: string read FFolder write setFolder;
    property   FoldersToo: Boolean read FFoldersToo write setFoldersToo default True;
  end;

function FileCompare( Item1, Item2: Pointer): Integer;

var
  FDirection: integer;
  FSortType: TFileSortType;
  FCurrentDir: string;

implementation

//---------------------------------------------------------------------

function TFileStat.getIcon;
var
  fi: TShFileInfo;
begin

  if FIcon = -1 then begin
    ShGetFileInfo(PChar(FCurrentDir+Name),0,fi, SizeOf(TShFileInfo), SHGFI_SYSICONINDEX );
    Result := fi.iIcon;
    FIcon  := fi.iIcon;
  end else
    Result := FIcon;

end;

//---------------------------------------------------------------------

function TFileStat.getHint;
var
  fi: TShFileInfo;
begin

  if FHint[1] = '.' then begin
    ShGetFileInfo(PChar(FCurrentDir+Name),0,fi, SizeOf(TShFileInfo), SHGFI_TYPENAME );
    Result := fi.szTypeName;
    FHint  := fi.szTypeName;
  end else
    Result := FHint;

end;

//---------------------------------------------------------------------

function TFileHolder.GetFileStat(Index: integer): TFileStat;
begin
  Result:=TFileStat(Items[Index]);
end;

//---------------------------------------------------------------------

procedure TFileHolder.PutFileStat(Index: integer; FileList: TFileStat);
begin
  Items[Index]:=FileList;
end;

//---------------------------------------------------------------------

procedure TFileHolder.clearList;
var
  i: integer;
begin

  for i := Count - 1 downto 0 do
    TFileStat(Items[i]).Free;
  Clear;

end;

//---------------------------------------------------------------------

destructor TFileHolder.Destroy;
begin

  clearList;
  inherited Destroy;

end;

//---------------------------------------------------------------------

procedure TFileHolder.readFiles;
var
  i: integer;
  fs: TFileStat;
  sRec: TSearchRec;

  function AttrToStr(attr: integer): string;
  begin
    Result := '';
    if (attr and faArchive) > 0 then
      Result := Result + 'A' else Result := Result + ' ';
    if (attr and faHidden) > 0 then
      Result := Result + 'H' else Result := Result + ' ';
    if (attr and faReadOnly) > 0 then
      Result := Result + 'R' else Result := Result + ' ';
    if (attr and faSysFile) > 0 then
      Result := Result + 'S' else Result := Result + ' ';
  end;

begin

  clearList;

  i := FindFirst(FFolder + '*.*', faDirectory, sRec);
  try
    while (i = 0) do begin
      if ((sRec.attr and faDirectory)=0) or // a file
         (FFoldersToo and ((sRec.attr and faDirectory)>0) and (sRec.Name[1] <> '.')) then begin
        fs := TFileStat.Create;
        fs.Name := sRec.Name;
        fs.Date := FileDateToDateTime(sRec.Time);
        fs.Attr := AttrToStr(sRec.Attr);
        fs.Icon := -1;
        fs.Hint := '.';
        fs.Fldr := (sRec.Attr and faDirectory)>0;
        if not fs.Fldr then
          fs.Size := Format( '%.0n', [sRec.Size+0.0] )
        else
          fs.Size := '';
        Add( fs );
      end;
      i := FindNext(sRec);
      Application.ProcessMessages;
    end;
  finally
    SysUtils.FindClose(sRec);
  end;

end;

//------------------------------------------------------------------

function FileCompare(item1, item2: Pointer): integer;
var
  comp1, comp2: string;

  function iif(TF: Boolean; ifT, ifF: string): string;
  begin
    if TF then Result := ifT else Result := ifF;
  end;

begin

  case FSortType of
    sbName: begin
      comp1 := TFileStat(Item1).Name;
      comp2 := TFileStat(Item2).Name;
    end;
    sbDate: begin
      comp1 := Format( '%0.3f', [TFileStat(Item1).Date] );
      comp2 := Format( '%0.3f', [TFileStat(Item2).Date] );
    end;
    sbSize: begin
      comp1 := Format( '%9.9s', [TFileStat(Item1).Size] );
      comp2 := Format( '%9.9s', [TFileStat(Item2).Size] );
    end;
    sbType: begin
      comp1 := TFileStat(Item1).Hint;
      comp2 := TFileStat(Item2).Hint;
    end;
    sbAttr: begin
      comp1 := TFileStat(Item1).Attr;
      comp2 := TFileStat(Item2).Attr;
    end;
  end;

  comp1 := iif(TFileStat(Item1).Fldr,'!','~') + comp1;
  comp2 := iif(TFileStat(Item2).Fldr,'!','~') + comp2;
  Result := FDirection * CompareText( comp1, comp2 );

end;

//---------------------------------------------------------------------

procedure TFileHolder.sortFiles(sortType: TFileSortType; ascending: Boolean);
begin

  FSortType := sortType;
  if ascending then
    FDirection := 1
  else
    FDirection := -1;
  Sort(FileCompare);

end;

//---------------------------------------------------------------------

procedure TFileHolder.setFolder(value: string);
begin

  FFolder := value;
  if FFolder[Length(FFolder)] <> '\' then
    FFolder := FFolder + '\';
  FCurrentDir := FFolder;

end;

//---------------------------------------------------------------------

procedure TFileHolder.setFoldersToo(value: Boolean);
begin

  FFoldersToo := value;

end;

end.